home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / ADVISE.S next >
Encoding:
Text File  |  1993-10-24  |  8.9 KB  |  336 lines
  1. ; ADVISE.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        MIT Scheme Advisory Procedures                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Oct 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. (begin
  23.   (define *args*)
  24.   (define *proc*)
  25.   (define *result*)
  26.   (define advise-entry)
  27.   (define advise-exit)
  28.   (define break)
  29.   (define break-both)
  30.   (define break-entry)
  31.   (define break-exit)
  32.   (define trace)
  33.   (define trace-both)
  34.   (define trace-entry)
  35.   (define trace-exit)
  36.   (define unadvise)
  37.   (define unadvise-entry)
  38.   (define unadvise-exit)
  39.   (define unbreak)
  40.   (define unbreak-entry)
  41.   (define unbreak-exit)
  42.   (define untrace)
  43.   (define untrace-entry)
  44.   (define untrace-exit)
  45.   (define %advise-info-vector-list)
  46.   )
  47.  
  48. ;;; info-vector format:
  49. ;;;
  50. ;;;    0 : LINK        next info-vector / ()        ** NOT USED **
  51. ;;;    1 : WRAPPER        orig closure object with new contents
  52. ;;;    2 : WRAPPEE        new closure object with old contents
  53. ;;;    3 : ENTRY-ADVICE    list of entry procedures / ()
  54. ;;;    4 : EXIT-ADVICE        list of exit procedures / ()
  55. ;;;
  56. ;;; closure object format:
  57. ;;;
  58. ;;;    -1 : LENGTH        (indices are for use with %REIFY)
  59. ;;;    0 : DEBUG-INFO        source, name, etc
  60. ;;;    1 : ENVIRONMENT        environment object
  61. ;;;    2 : CB displacement    VM address
  62. ;;;    3 : CB offset to entry    VM fixnum
  63. ;;;    4 : NARGS        fixnum
  64.  
  65.  
  66. (letrec
  67.  (
  68.   (*args*value    '())                    ; *ARGS*VALUE
  69.   (*proc*value    '())                    ; *PROC*VALUE
  70.   (*result*value  '())                    ; *RESULT*VALUE
  71.  
  72.   (info-vector-list '())                ; INFO-VECTOR-LIST
  73.  
  74.  
  75.   (add-advice                        ; ADD-ADVICE
  76.    (lambda (proc advice index)
  77.      (if (and (closure? proc)(closure? advice))
  78.      (let* ((info (get-info-vector proc info-vector-list))
  79.         (advl (vector-ref info index)))
  80.        (when (not (memq advice advl))
  81.          (vector-set! info index
  82.                   (cons advice advl)))
  83.        'OK)
  84.      (%error-invalid-operand-list 'ADVISE proc advice))))
  85.  
  86.  
  87.   (get-info-vector                    ; GET-INFO-VECTOR
  88.    (lambda (wrappee iv-list)
  89.      (cond ((null? iv-list)
  90.         (let* ((info    (make-vector 5 '()))
  91.            (wrapper (make-wrapper info)))
  92.           (set! info-vector-list
  93.             (cons info info-vector-list))
  94.           (swap-closure-contents
  95.               wrapper wrappee 4)
  96.           (vector-set! info 1        ; 1=WRAPPER
  97.                wrappee)        ;    swap!
  98.           (vector-set! info 2        ; 2=WRAPPEE
  99.                wrapper)        ;    swap!
  100.           info))
  101.        ((eq? wrappee
  102.          (vector-ref (car iv-list) 1))    ; 1=WRAPPER (not WRAPPEE)
  103.         (car iv-list))
  104.        (else
  105.         (get-info-vector wrappee (cdr iv-list))))))
  106.  
  107.  
  108.   (swap-closure-contents                ; SWAP-CLOSURE-CONTENTS
  109.    (lambda (wrapper wrappee index)
  110.      (if (zero? index)
  111.      (%reify! wrapper index        ; copy the debug info
  112.           (%reify wrappee index))
  113.      (let ((value (%reify wrapper index)))
  114.        (%reify! wrapper index (%reify wrappee index))
  115.        (%reify! wrappee index value)
  116.        (swap-closure-contents wrapper wrappee (- index 1))))))
  117.  
  118.  
  119.   (rem-advice                        ; REM-ADVICE
  120.    (lambda (args    ; (proc) -or- () ==> all
  121.         advice    ; advice-proc -or- () ==> all
  122.         index)    ; 3 -or- 4, entry/exit
  123.      (let ((proc (car args)))
  124.        (when (and proc (not (closure? proc)))
  125.          (apply %error-invalid-operand-list
  126.             (cons 'UNADVISE args)))
  127.        (remove-advice proc advice index
  128.               info-vector-list '())
  129.        'OK)))
  130.  
  131.  
  132.   (remove-advice                    ; REMOVE-ADVICE
  133.    (lambda (proc advice index iv-list new-iv-list)
  134.      (if (null? iv-list)
  135.      (set! info-vector-list new-iv-list)
  136.      (let ((info (car iv-list)))
  137.        (cond ((null? proc)
  138.           (vector-set! info index '()))
  139.          ((eq? proc (vector-ref info 1))
  140.           (vector-set! info index
  141.                    (if (null? advice)
  142.                    '()
  143.                    (delq! advice
  144.                       (vector-ref info index))))))
  145.        (if (or (vector-ref info 3)
  146.            (vector-ref info 4))
  147.            (remove-advice proc advice index
  148.                   (cdr iv-list)
  149.                   (cons info new-iv-list))
  150.            (begin
  151.          (swap-closure-contents
  152.              (vector-ref info 1)    ; 1=WRAPPER
  153.              (vector-ref info 2)    ; 2=WRAPPEE
  154.              4)
  155.          (remove-advice proc advice index
  156.                 (cdr iv-list)
  157.                 new-iv-list)))))))
  158.  
  159.  
  160.   (make-wrapper                        ; MAKE-WRAPPER
  161.    (lambda (info-vector)
  162.      (lambda args
  163.        (call/cc
  164.      (fluid-lambda (%*BREAK*continuation)
  165.        (let* ((info info-vector)        ; cache INFO-VECTOR
  166.           (proc (vector-ref info 2))    ; 2=WRAPPEE
  167.           (env  (procedure-environment proc)))
  168.          (do ((advice (vector-ref info 3)    ; 3=ENTRY-ADVICE
  169.               (cdr advice)))
  170.          ((null? advice))
  171.            ((car advice) proc args env))
  172.          (do ((result (apply proc args)
  173.               ((car advice) proc args result env))
  174.           (advice (vector-ref info 4)    ; 4=EXIT-ADVICE
  175.               (cdr advice)))
  176.          ((null? advice)
  177.           result))))))))
  178.  
  179.  
  180.   (print-arg-list                    ; PRINT-ARG-LIST
  181.    (lambda (num args)
  182.      (newline)
  183.      (when args
  184.        (princ "  Argument ") (princ num) (princ ": ")
  185.        (prin1 (car args))
  186.        (print-arg-list (+ num 1) (cdr args)))))
  187.  
  188.  
  189.   (std-break-entry                    ; STD-BREAK-ENTRY
  190.    (lambda (proc args env)
  191.      (set! *proc*value proc)
  192.      (set! *args*value args)
  193.      (set! *result*value '())
  194.      (breakpoint-procedure 'BREAK-ENTRY
  195.                (cons proc args)
  196.                env
  197.                (%reify-stack
  198.                    (+ (%reify-stack
  199.                       (+ (%reify-stack -1) 6)) 6)))
  200.      *args*value))
  201.  
  202.  
  203.   (std-break-exit                    ; STD-BREAK-EXIT
  204.    (lambda (proc args result env)
  205.      (set! *proc*value proc)
  206.      (set! *args*value args)
  207.      (set! *result*value result)
  208.      (breakpoint-procedure 'BREAK-EXIT
  209.                (list (cons proc args)
  210.                  '|-->|
  211.                  result)
  212.                env
  213.                (%reify-stack
  214.                    (+ (%reify-stack
  215.                       (+ (%reify-stack -1) 6)) 6)))
  216.      *result*value))
  217.  
  218.  
  219.   (std-trace-entry                    ; STD-TRACE-ENTRY
  220.    (lambda (proc args env)
  221.      (fresh-line)
  222.      (princ " >>> Entering ")
  223.      (prin1 proc)
  224.      (print-arg-list 1 args)
  225.      args))
  226.  
  227.  
  228.   (std-trace-exit                    ; STD-TRACE-EXIT
  229.    (lambda (proc args result env)
  230.      (fresh-line)
  231.      (princ " <<< Leaving ")
  232.      (prin1 proc)
  233.      (princ " with value ")
  234.      (prin1 result)
  235.      (print-arg-list 1 args)
  236.      result))
  237.  
  238.   ) ; --------------------------------------------------------------
  239.  (begin
  240.  
  241.   (set! *args*                        ; *ARGS*
  242.     (lambda () *args*value))
  243.  
  244.   (set! *proc*                        ; *PROC*
  245.     (lambda () *proc*value))
  246.  
  247.   (set! *result*                    ; *RESULT*
  248.     (lambda () *result*value))
  249.  
  250.   (set! advise-entry                    ; ADVISE-ENTRY
  251.    (lambda (proc advice)
  252.      (add-advice proc advice 3)))
  253.  
  254.   (set! advise-exit                    ; ADVISE-EXIT
  255.    (lambda (proc advice)
  256.      (add-advice proc advice 4)))
  257.  
  258.   (set! break                        ; BREAK
  259.    (lambda (proc)
  260.      (add-advice proc std-break-entry 3)))
  261.  
  262.   (set! break-both                    ; BREAK-BOTH
  263.    (lambda (proc)
  264.      (break-entry proc)
  265.      (break-exit proc)))
  266.  
  267.   (set! break-entry                    ; BREAK-ENTRY
  268.    (lambda (proc)
  269.      (add-advice proc std-break-entry 3)))
  270.  
  271.   (set! break-exit                    ; BREAK-EXIT
  272.    (lambda (proc)
  273.      (add-advice proc std-break-exit 4)))
  274.  
  275.   (set! trace                        ; TRACE
  276.     (lambda (proc)
  277.       (add-advice proc std-trace-entry 3)))
  278.  
  279.   (set! trace-both                    ; TRACE-BOTH
  280.    (lambda (proc)
  281.      (trace-entry proc)
  282.      (trace-exit proc)))
  283.  
  284.   (set! trace-entry                    ; TRACE-ENTRY
  285.    (lambda (proc)
  286.      (add-advice proc std-trace-entry 3)))
  287.  
  288.   (set! trace-exit                    ; TRACE-EXIT
  289.    (lambda (proc)
  290.      (add-advice proc std-trace-exit 4)))
  291.  
  292.   (set! unadvise                    ; UNADVISE
  293.     (lambda args
  294.       (rem-advice args '() 3)
  295.       (rem-advice args '() 4)))
  296.  
  297.   (set! unadvise-entry                    ; UNADVISE-ENTRY
  298.     (lambda args
  299.       (rem-advice args '() 3)))
  300.  
  301.   (set! unadvise-exit                    ; UNADVISE-EXIT
  302.     (lambda args
  303.       (rem-advice args '() 4)))
  304.  
  305.   (set! unbreak                        ; UNBREAK
  306.     (lambda args
  307.       (rem-advice args std-break-entry 3)
  308.       (rem-advice args std-break-exit 4)))
  309.  
  310.   (set! unbreak-entry                    ; UNBREAK-ENTRY
  311.     (lambda args
  312.       (rem-advice args std-break-entry 3)))
  313.  
  314.   (set! unbreak-exit                    ; UNBREAK-EXIT
  315.     (lambda args
  316.       (rem-advice args std-break-exit 4)))
  317.  
  318.   (set! untrace                        ; UNTRACE
  319.     (lambda args
  320.       (rem-advice args std-trace-entry 3)
  321.       (rem-advice args std-trace-exit 4)))
  322.  
  323.   (set! untrace-entry                    ; UNTRACE-ENTRY
  324.     (lambda args
  325.       (rem-advice args std-trace-entry 3)))
  326.  
  327.   (set! untrace-exit                    ; UNTRACE-EXIT
  328.     (lambda args
  329.       (rem-advice args std-trace-exit 4)))
  330.  
  331.   (set! %advise-info-vector-list        ; for debugging ADVISE
  332.     (lambda () info-vector-list))
  333.  
  334.   )
  335.  )
  336.